home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / efs / efs-mts.el.z / efs-mts.el
Encoding:
Text File  |  1998-05-21  |  8.2 KB  |  240 lines
  1. ;; -*-Emacs-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;
  4. ;; File:         efs-mts.el
  5. ;; Release:      $efs release: 1.15 $
  6. ;; Version:      #Revision: 1.1 $
  7. ;; RCS:          
  8. ;; Description:  MTS support for efs
  9. ;; Author:       Sandy Rutherford <sandy@itp.ethz.ch>
  10. ;; Created:      Fri Oct 23 08:51:29 1992
  11. ;; Modified:     Sun Nov 27 18:37:18 1994 by sandy on gandalf
  12. ;; Language:     Emacs-Lisp
  13. ;;
  14. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  15.  
  16. ;;; This file is part of efs. See efs.el for copyright
  17. ;;; (it's copylefted) and warrranty (there isn't one) information.
  18.  
  19. (provide 'efs-mts)
  20. (require 'efs)
  21.  
  22. (defconst efs-mts-version
  23.   (concat (substring "$efs release: 1.15 $" 14 -2)
  24.       "/"
  25.       (substring "#Revision: 1.1 $" 11 -2)))
  26.  
  27. ;;;; ------------------------------------------------------------
  28. ;;;; MTS support
  29. ;;;; ------------------------------------------------------------
  30.  
  31. ;;; efs has full support, including tree dired support, for hosts running
  32. ;;; the Michigan terminal system.  It should be able to automatically
  33. ;;; recognize any MTS machine. We would be grateful if you
  34. ;;; would report any failures to automatically recognize a MTS host as a bug.
  35. ;;;
  36. ;;; Filename syntax:
  37. ;;; 
  38. ;;; MTS filenames are entered in a UNIX-y way. For example, if your account
  39. ;;; was YYYY, the file FILE in the account XXXX: on mtsg.ubc.ca would be
  40. ;;; entered as
  41. ;;;   /YYYY@mtsg.ubc.ca:/XXXX:/FILE
  42. ;;; In other words, MTS accounts are treated as UNIX directories. Of course,
  43. ;;; to access a file in another account, you must have access permission for
  44. ;;; it.  If FILE were in your own account, then you could enter it in a
  45. ;;; relative path fashion as
  46. ;;;   /YYYY@mtsg.ubc.ca:FILE
  47. ;;; MTS filenames can be up to 12 characters. Like UNIX, the structure of the
  48. ;;; filename does not contain a TYPE (i.e. it can have as many "."'s as you
  49. ;;; like.) MTS filenames are always in upper case, and hence be sure to enter
  50. ;;; them as such! MTS is not case sensitive, but an EMACS running under UNIX
  51. ;;; is.
  52.  
  53.  
  54. (defconst efs-mts-date-regexp
  55.   (concat
  56.    " \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct"
  57.    "\\|Nov\\|Dec\\) [ 123]?[0-9] "))
  58.  
  59. ;;; The following two functions are entry points to this file.
  60. ;;; They are put into the appropriate alists in efs.el
  61.  
  62. (efs-defun efs-fix-path mts (path &optional reverse)
  63.   ;; Convert PATH from UNIX-ish to MTS.
  64.   ;; If REVERSE given then convert from MTS to UNIX-ish.
  65.   (efs-save-match-data
  66.     (if reverse
  67.     (if (string-match "^\\([^:]+:\\)?\\(.*\\)$" path)
  68.         (let (acct file)
  69.           (if (match-beginning 1)
  70.           (setq acct (substring path 0 (match-end 1))))
  71.           (if (match-beginning 2)
  72.           (setq file (substring path
  73.                     (match-beginning 2) (match-end 2))))
  74.           (concat (and acct (concat "/" acct "/"))
  75.               file))
  76.       (error "path %s didn't match" path))
  77.       (if (string-match "^/\\([^:]+:\\)/\\(.*\\)$" path)
  78.       (concat (substring path 1 (match-end 1))
  79.           (substring path (match-beginning 2) (match-end 2)))
  80.     ;; Let's hope that mts will recognize it anyway.
  81.     path))))
  82.  
  83. (efs-defun efs-fix-dir-path mts (dir-path)
  84. ;; Convert path from UNIX-ish to MTS ready for a DIRectory listing.
  85. ;; Remember that there are no directories in MTS.
  86.   (if (string-equal dir-path "/")
  87.       (error "Cannot get listing for fictitious \"/\" directory.")
  88.     (let ((dir-path (efs-fix-path 'mts dir-path)))
  89.       (cond
  90.        ((string-equal dir-path "")
  91.     "?")
  92.        ((efs-save-match-data (string-match ":$" dir-path))
  93.     (concat dir-path "?"))
  94.        (dir-path))))) ; It's just a single file.
  95.  
  96.  
  97. (efs-defun efs-parse-listing mts
  98.   (host user dir path &optional switches)
  99.   ;; Parse the current buffer which is assumed to be in
  100.   ;; mts ftp dir format.
  101.   ;; HOST = remote host name
  102.   ;; USER = remote user name
  103.   ;; DIR = remote directory as a remote full path
  104.   ;; PATH = directory as an efs full path
  105.   ;; SWITCHES are never used here, but they
  106.   ;; must be specified in the argument list for compatibility
  107.   ;; with the unix version of this function.
  108.   (let ((tbl (efs-make-hashtable))
  109.     perms)
  110.     (goto-char (point-min))
  111.     (efs-save-match-data
  112.       (while (re-search-forward efs-mts-date-regexp nil t)
  113.     (beginning-of-line)
  114.     (if (looking-at "[rwed]+")
  115.         (setq perms (buffer-substring (match-beginning 0) (match-end 0)))
  116.       (setq perms nil))
  117.     (end-of-line)
  118.     (skip-chars-backward " ")
  119.     (let ((end (point)))
  120.       (skip-chars-backward "-A-Z0-9_.!")
  121.       (efs-put-hash-entry (buffer-substring (point) end)
  122.                    (list nil nil nil perms) tbl))
  123.     (forward-line 1)))
  124.       ;; Don't need to bother with ..
  125.     (efs-put-hash-entry "." '(t) tbl)
  126.     tbl))
  127.  
  128. (efs-defun efs-allow-child-lookup mts (host user dir file)
  129.   ;; Returns t if FILE in directory DIR could possibly be a subdir
  130.   ;; according to its file-name syntax, and therefore a child listing should
  131.   ;; be attempted.
  132.  
  133.   ;; MTS file system is flat. Only "accounts" are subdirs.
  134.   (string-equal "/" dir))
  135.  
  136. (efs-defun efs-internal-file-writable-p mts (user owner modes)
  137.   (if (stringp modes)
  138.       (efs-save-match-data
  139.     (null (null (string-match "w" modes))))
  140.     t)) ; guess
  141.  
  142. (efs-defun efs-internal-file-readable-p mts (user owner modes)
  143.   (if (stringp modes)
  144.       (efs-save-match-data
  145.     (null (null (string-match "r" modes))))
  146.     t)) ; guess
  147.  
  148. ;;; Tree dired support:
  149.  
  150. ;; There aren't too many systems left that use MTS. This dired support will
  151. ;; work for the implementation of ftp on mtsg.ubc.ca. I hope other mts systems
  152. ;; implement ftp in the same way. If not, it might be necessary to make the
  153. ;; following more flexible.
  154.  
  155. (defconst efs-dired-mts-re-exe nil)
  156.  
  157. (or (assq 'mts efs-dired-re-exe-alist)
  158.     (setq efs-dired-re-exe-alist
  159.       (cons (cons 'mts  efs-dired-mts-re-exe)
  160.         efs-dired-re-exe-alist)))
  161.  
  162. (defconst efs-dired-mts-re-dir nil)
  163.  
  164. (or (assq 'mts efs-dired-re-dir-alist)
  165.     (setq efs-dired-re-dir-alist
  166.       (cons (cons 'mts  efs-dired-mts-re-dir)
  167.         efs-dired-re-dir-alist)))
  168.  
  169. (efs-defun efs-dired-manual-move-to-filename mts
  170.   (&optional raise-error bol eol)
  171.   ;; In dired, move to first char of filename on this line.
  172.   ;; Returns position (point) or nil if no filename on this line.
  173.   ;; This is the MTS version.
  174.   (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point))))
  175.   (if bol
  176.       (goto-char bol)
  177.     (skip-chars-backward "^\n\r"))
  178.   (if (re-search-forward efs-mts-date-regexp eol t)
  179.       (progn
  180.     (skip-chars-forward " ")      ; Eat blanks after date
  181.     (skip-chars-forward "0-9:")   ; Eat time or year
  182.     (skip-chars-forward " ")      ; one space before filename
  183.     (point))
  184.     (and raise-error (error "No file on this line"))))
  185.  
  186. (efs-defun efs-dired-manual-move-to-end-of-filename mts
  187.   (&optional no-error bol eol)
  188.   ;; Assumes point is at beginning of filename.
  189.   ;; So, it should be called only after (dired-move-to-filename t).
  190.   ;; On failure, signals an error or returns nil.
  191.   ;; This is the MTS version.
  192.   (let ((opoint (point)))
  193.     (and selective-display
  194.      (null no-error)
  195.      (eq (char-after
  196.           (1- (or bol (save-excursion
  197.                 (skip-chars-backward "^\r\n")
  198.                 (point)))))
  199.          ?\r)
  200.      ;; File is hidden or omitted.
  201.      (cond
  202.       ((dired-subdir-hidden-p (dired-current-directory))
  203.        (error
  204.         (substitute-command-keys
  205.          "File line is hidden. Type \\[dired-hide-subdir] to unhide.")))
  206.       ((error
  207.         (substitute-command-keys
  208.          "File line is omitted. Type \\[dired-omit-toggle] to un-omit."
  209.          )))))
  210.     (skip-chars-forward "-A-Z0-9._!")
  211.     (if (or (= opoint (point)) (not (memq (following-char) '(?\r ?\n))))
  212.     (if no-error
  213.         nil
  214.       (error "No file on this line"))
  215.       (point))))
  216.  
  217. (efs-defun efs-dired-fixup-listing mts (file path &optional switches wildcard)
  218.   ;; If you're not listing your own account, MTS puts the
  219.   ;; account name in front of each filename. Scrape them off.
  220.   ;; PATH will have unix /'s on it.
  221.   ;; file-name-directory is in case of wildcards
  222.   (let ((len (length path)))
  223.     (if (> len 2)
  224.     (progn
  225.       (if (= (aref path (1- len)) ?/)
  226.           (setq path (substring path -2))
  227.         (setq path (substring path -1)))
  228.       (goto-char (point-min))
  229.       (while (search-forward path nil t)
  230.         (delete-region (match-beginning 0) (match-end 0)))))))
  231.  
  232. (efs-defun efs-dired-insert-headerline mts (dir)
  233.   ;; MTS has no total line, so we insert a blank line for
  234.   ;; aesthetics.
  235.   (insert "\n")
  236.   (forward-char -1)
  237.   (efs-real-dired-insert-headerline dir))
  238.  
  239. ;;; end of efs-mts.el
  240.